home *** CD-ROM | disk | FTP | other *** search
/ NeXT Education Software Sampler 1992 Fall / NeXT Education Software Sampler 1992 Fall.iso / Programming / Source / winterp-1.13 / examples / xlisp-2.1 / init.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1991-10-06  |  3.0 KB  |  84 lines
  1. ; -*-Lisp-*-
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;
  4. ; File:         init.lsp
  5. ; RCS:          $Header: $
  6. ; Description:    initialization file for XLISP 2.1
  7. ; Author:       David Betz
  8. ; Created:      Sat Oct  5 21:04:55 1991
  9. ; Modified:     Sat Oct  5 21:05:16 1991 (Niels Mayer) mayer@hplnpm
  10. ; Language:     Lisp
  11. ; Package:      N/A
  12. ; Status:       X11r5 contrib tape release
  13. ;
  14. ; WINTERP Copyright 1989, 1990, 1991 Hewlett-Packard Company (by Niels Mayer).
  15. ; XLISP version 2.1, Copyright (c) 1989, by David Betz.
  16. ;
  17. ; Permission to use, copy, modify, distribute, and sell this software and its
  18. ; documentation for any purpose is hereby granted without fee, provided that
  19. ; the above copyright notice appear in all copies and that both that
  20. ; copyright notice and this permission notice appear in supporting
  21. ; documentation, and that the name of Hewlett-Packard and Niels Mayer not be
  22. ; used in advertising or publicity pertaining to distribution of the software
  23. ; without specific, written prior permission.  Hewlett-Packard and Niels Mayer
  24. ; makes no representations about the suitability of this software for any
  25. ; purpose.  It is provided "as is" without express or implied warranty.
  26. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  27.  
  28. ; define some macros
  29. (defmacro defvar (sym &optional val)
  30.   `(if (boundp ',sym) ,sym (setq ,sym ,val)))
  31. (defmacro defparameter (sym val)
  32.   `(setq ,sym ,val))
  33. (defmacro defconstant (sym val)
  34.   `(setq ,sym ,val))
  35.  
  36. ; (makunbound sym) - make a symbol value be unbound
  37. (defun makunbound (sym) (setf (symbol-value sym) '*unbound*) sym)
  38.  
  39. ; (fmakunbound sym) - make a symbol function be unbound
  40. (defun fmakunbound (sym) (setf (symbol-function sym) '*unbound*) sym)
  41.  
  42. ; (mapcan fun list [ list ]...)
  43. (defmacro mapcan (&rest args) `(apply #'nconc (mapcar ,@args)))
  44.  
  45. ; (mapcon fun list [ list ]...)
  46. (defmacro mapcon (&rest args) `(apply #'nconc (maplist ,@args)))
  47.  
  48. ; (set-macro-character ch fun [ tflag ])
  49. (defun set-macro-character (ch fun &optional tflag)
  50.     (setf (aref *readtable* (char-int ch))
  51.           (cons (if tflag :tmacro :nmacro) fun))
  52.     t)
  53.  
  54. ; (get-macro-character ch)
  55. (defun get-macro-character (ch)
  56.   (if (consp (aref *readtable* (char-int ch)))
  57.     (cdr (aref *readtable* (char-int ch)))
  58.     nil))
  59.  
  60. ; (savefun fun) - save a function definition to a file
  61. (defmacro savefun (fun)
  62.   `(let* ((fname (strcat (symbol-name ',fun) ".lsp"))
  63.           (fval (get-lambda-expression (symbol-function ',fun)))
  64.           (fp (open fname :direction :output)))
  65.      (cond (fp (print (cons (if (eq (car fval) 'lambda)
  66.                                 'defun
  67.                                 'defmacro)
  68.                             (cons ',fun (cdr fval))) fp)
  69.                (close fp)
  70.                fname)
  71.            (t nil))))
  72.  
  73. ; (debug) - enable debug breaks
  74. (defun debug ()
  75.        (setq *breakenable* t))
  76.  
  77. ; (nodebug) - disable debug breaks
  78. (defun nodebug ()
  79.        (setq *breakenable* nil))
  80.  
  81. ; initialize to enable breaks but no trace back
  82. (setq *breakenable* t)
  83. (setq *tracenable* nil)
  84.